home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlbfun.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-10  |  13.6 KB  |  756 lines
  1. /* xlbfun.c - xlisp basic built-in functions */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8.  
  9. /* external variables */
  10. extern LVAL xlenv,xlfenv,xldenv,true;
  11. extern LVAL s_evalhook,s_applyhook;
  12. extern LVAL s_unbound;
  13. extern char gsprefix[];
  14. extern FIXTYPE gsnumber;
  15.  
  16. /* forward declarations */
  17. #ifdef ANSI
  18. LVAL makesymbol(int iflag);
  19. #else
  20. FORWARD LVAL makesymbol();
  21. #endif
  22.  
  23. /* xeval - the built-in function 'eval' */
  24. LVAL xeval()
  25. {
  26.     LVAL expr;
  27.  
  28.     /* get the expression to evaluate */
  29.     expr = xlgetarg();
  30.     xllastarg();
  31.  
  32.     /* evaluate the expression */
  33.     return (xleval(expr));
  34. }
  35.  
  36. /* xapply - the built-in function 'apply' */
  37. LVAL xapply()
  38. {
  39.     LVAL fun,arglist;
  40.  
  41.     /* get the function and argument list */
  42.     fun = xlgetarg();
  43.     arglist = xlgalist();
  44.     xllastarg();
  45.  
  46.     /* apply the function to the arguments */
  47.     return (xlapply(pushargs(fun,arglist)));
  48. }
  49.  
  50. /* xfuncall - the built-in function 'funcall' */
  51. LVAL xfuncall()
  52. {
  53.     LVAL *newfp;
  54.     int argc;
  55.     
  56.     /* build a new argument stack frame */
  57.     newfp = xlsp;
  58.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  59.     pusharg(xlgetarg());
  60.     pusharg(NIL); /* will be argc */
  61.  
  62.     /* push each argument */
  63.     for (argc = 0; moreargs(); ++argc)
  64.         pusharg(nextarg());
  65.  
  66.     /* establish the new stack frame */
  67.     newfp[2] = cvfixnum((FIXTYPE)argc);
  68.     xlfp = newfp;
  69.  
  70.     /* apply the function to the arguments */
  71.     return (xlapply(argc));
  72. }
  73.  
  74. /* xmacroexpand - expand a macro call repeatedly */
  75. LVAL xmacroexpand()
  76. {
  77.     LVAL form;
  78.     form = xlgetarg();
  79.     xllastarg();
  80.     return (xlexpandmacros(form));
  81. }
  82.  
  83. /* x1macroexpand - expand a macro call */
  84. LVAL x1macroexpand()
  85. {
  86.     LVAL form,fun,args;
  87.  
  88.     /* protect some pointers */
  89.     xlstkcheck(2);
  90.     xlsave(fun);
  91.     xlsave(args);
  92.  
  93.     /* get the form */
  94.     form = xlgetarg();
  95.     xllastarg();
  96.  
  97.     /* expand until the form isn't a macro call */
  98.     if (consp(form)) {
  99.         fun = car(form);                /* get the macro name */
  100.         args = cdr(form);                /* get the arguments */
  101.         if (symbolp(fun) && fboundp(fun)) {
  102.             fun = xlgetfunction(fun);    /* get the expansion function */
  103.             macroexpand(fun,args,&form);
  104.         }
  105.     }
  106.  
  107.     /* restore the stack and return the expansion */
  108.     xlpopn(2);
  109.     return (form);
  110. }
  111.  
  112. /* xatom - is this an atom? */
  113. LVAL xatom()
  114. {
  115.     LVAL arg;
  116.     arg = xlgetarg();
  117.     xllastarg();
  118.     return (atom(arg) ? true : NIL);
  119. }
  120.  
  121. /* xsymbolp - is this an symbol? */
  122. LVAL xsymbolp()
  123. {
  124.     LVAL arg;
  125.     arg = xlgetarg();
  126.     xllastarg();
  127.     return (arg == NIL || symbolp(arg) ? true : NIL);
  128. }
  129.  
  130. /* xnumberp - is this a number? */
  131. LVAL xnumberp()
  132. {
  133.     LVAL arg;
  134.     arg = xlgetarg();
  135.     xllastarg();
  136.     return (fixp(arg) || floatp(arg) ? true : NIL);
  137. }
  138.  
  139. /* xintegerp - is this an integer? */
  140. LVAL xintegerp()
  141. {
  142.     LVAL arg;
  143.     arg = xlgetarg();
  144.     xllastarg();
  145.     return (fixp(arg) ? true : NIL);
  146. }
  147.  
  148. /* xfloatp - is this a float? */
  149. LVAL xfloatp()
  150. {
  151.     LVAL arg;
  152.     arg = xlgetarg();
  153.     xllastarg();
  154.     return (floatp(arg) ? true : NIL);
  155. }
  156.  
  157. /* xcharp - is this a character? */
  158. LVAL xcharp()
  159. {
  160.     LVAL arg;
  161.     arg = xlgetarg();
  162.     xllastarg();
  163.     return (charp(arg) ? true : NIL);
  164. }
  165.  
  166. /* xstringp - is this a string? */
  167. LVAL xstringp()
  168. {
  169.     LVAL arg;
  170.     arg = xlgetarg();
  171.     xllastarg();
  172.     return (stringp(arg) ? true : NIL);
  173. }
  174.  
  175. /* xarrayp - is this an array? */
  176. LVAL xarrayp()
  177. {
  178.     LVAL arg;
  179.     arg = xlgetarg();
  180.     xllastarg();
  181.     return (vectorp(arg) ? true : NIL);
  182. }
  183.  
  184. /* xstreamp - is this a stream? */
  185. LVAL xstreamp()
  186. {
  187.     LVAL arg;
  188.     arg = xlgetarg();
  189.     xllastarg();
  190.     return (streamp(arg) || ustreamp(arg) ? true : NIL);
  191. }
  192.  
  193. /* xobjectp - is this an object? */
  194. LVAL xobjectp()
  195. {
  196.     LVAL arg;
  197.     arg = xlgetarg();
  198.     xllastarg();
  199.     return (objectp(arg) ? true : NIL);
  200. }
  201.  
  202. /* xboundp - is this a value bound to this symbol? */
  203. LVAL xboundp()
  204. {
  205.     LVAL sym;
  206.     sym = xlgasymornil();    /* TAA fix */
  207.     xllastarg();
  208.     return (sym == NIL || boundp(sym) ? true : NIL);
  209. }
  210.  
  211. /* xfboundp - is this a functional value bound to this symbol? */
  212. LVAL xfboundp()
  213. {
  214.     LVAL sym;
  215.     sym = xlgasymornil();    /* TAA fix */
  216.     xllastarg();
  217.     return (sym != NIL && fboundp(sym) ? true : NIL);
  218. }
  219.  
  220. /* xnull - is this null? */
  221. LVAL xnull()
  222. {
  223.     LVAL arg;
  224.     arg = xlgetarg();
  225.     xllastarg();
  226.     return (null(arg) ? true : NIL);
  227. }
  228.  
  229. /* xlistp - is this a list? */
  230. LVAL xlistp()
  231. {
  232.     LVAL arg;
  233.     arg = xlgetarg();
  234.     xllastarg();
  235.     return (listp(arg) ? true : NIL);
  236. }
  237.  
  238. /* xendp - is this the end of a list? */
  239. LVAL xendp()
  240. {
  241.     LVAL arg;
  242.     arg = xlgalist();
  243.     xllastarg();
  244.     return (null(arg) ? true : NIL);
  245. }
  246.  
  247. /* xconsp - is this a cons? */
  248. LVAL xconsp()
  249. {
  250.     LVAL arg;
  251.     arg = xlgetarg();
  252.     xllastarg();
  253.     return (consp(arg) ? true : NIL);
  254. }
  255.  
  256. /* xeq - are these equal? */
  257. LVAL xeq()
  258. {
  259.     LVAL arg1,arg2;
  260.  
  261.     /* get the two arguments */
  262.     arg1 = xlgetarg();
  263.     arg2 = xlgetarg();
  264.     xllastarg();
  265.  
  266.     /* compare the arguments */
  267.     return (arg1 == arg2 ? true : NIL);
  268. }
  269.  
  270. /* xeql - are these equal? */
  271. LVAL xeql()
  272. {
  273.     LVAL arg1,arg2;
  274.  
  275.     /* get the two arguments */
  276.     arg1 = xlgetarg();
  277.     arg2 = xlgetarg();
  278.     xllastarg();
  279.  
  280.     /* compare the arguments */
  281.     return (eql(arg1,arg2) ? true : NIL);
  282. }
  283.  
  284. /* xequal - are these equal? (recursive) */
  285. LVAL xequal()
  286. {
  287.     LVAL arg1,arg2;
  288.  
  289.     /* get the two arguments */
  290.     arg1 = xlgetarg();
  291.     arg2 = xlgetarg();
  292.     xllastarg();
  293.  
  294.     /* compare the arguments */
  295.     return (equal(arg1,arg2) ? true : NIL);
  296. }
  297.  
  298. /* xset - built-in function set */
  299. LVAL xset()
  300. {
  301.     LVAL sym,val;
  302.  
  303.     /* get the symbol and new value */
  304.     sym = xlgasymbol();
  305.     val = xlgetarg();
  306.     xllastarg();
  307.  
  308.     /* assign the symbol the value of argument 2 and the return value */
  309.     setvalue(sym,val);
  310.  
  311.     /* return the result value */
  312.     return (val);
  313. }
  314.  
  315. /* xgensym - generate a symbol */
  316. LVAL xgensym()
  317. {
  318.     char sym[STRMAX+11]; /* enough space for prefix and number */
  319.     LVAL x;
  320.  
  321.     /* get the prefix or number */
  322.     if (moreargs()) {
  323.         x = xlgetarg();
  324.         switch (null(x)? CONS : ntype(x)) { /* was ntype(x)      TAA Mod */
  325.         case SYMBOL:
  326.                 x = getpname(x);
  327.         case STRING:
  328.                 strncpy(gsprefix,(char *)getstring(x),STRMAX);
  329.                 gsprefix[STRMAX] = '\0';
  330.                 break;
  331.         case FIXNUM:
  332.                 gsnumber = getfixnum(x);
  333.                 break;
  334.         default:
  335.                 xlbadtype(x);
  336.         }
  337.     }
  338.     xllastarg();
  339.  
  340.     /* create the pname of the new symbol */
  341.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  342.  
  343.     /* make a symbol with this print name */
  344.     return (xlmakesym(sym));
  345. }
  346.  
  347. /* xmakesymbol - make a new uninterned symbol */
  348. LVAL xmakesymbol()
  349. {
  350.     return (makesymbol(FALSE));
  351. }
  352.  
  353. /* xintern - make a new interned symbol */
  354. LVAL xintern()
  355. {
  356.     return (makesymbol(TRUE));
  357. }
  358.  
  359. /* makesymbol - make a new symbol */
  360. LOCAL LVAL makesymbol(iflag)
  361.   int iflag;
  362. {
  363.     LVAL pname;
  364.         int i;
  365.  
  366.  
  367.     /* get the print name of the symbol to intern */
  368.     pname = xlgastring();
  369.     xllastarg();
  370.         
  371.         /* check for making "NIL" -- very bad */
  372.         if (strcmp((char *)getstring(pname),"NIL") == 0)
  373.                 xlerror("you've got to be kidding!",NIL);
  374.  
  375.         /* check for containing only printable characters */
  376.         i = getslength(pname)-1;
  377.         while (i-- > 0) if (pname->n_string[i] < 32 )
  378.                 xlerror("string contains non-printing characters",pname);
  379.         
  380.  
  381.     /* make the symbol */
  382.     return (iflag ? xlenter((char *)getstring(pname))
  383.                   : xlmakesym((char *)getstring(pname)));
  384. }
  385.  
  386. /* xsymname - get the print name of a symbol */
  387. LVAL xsymname()
  388. {
  389.     LVAL sym;
  390.  
  391.     /* get the symbol */
  392.     sym = xlgasymornil();    /* TAA fix */
  393.     xllastarg();
  394.  
  395.     /* handle NIL, which is not internally represented as a symbol */
  396.     if (sym == NIL) {
  397.         sym = newstring(4);
  398.         strcpy((char *)getstring(sym), "NIL");
  399.         return sym;
  400.     }
  401.  
  402.     /* return the print name */
  403.     return (getpname(sym));
  404. }
  405.  
  406. /* xsymvalue - get the value of a symbol */
  407. LVAL xsymvalue()
  408. {
  409.     LVAL sym,val;
  410.  
  411.     /* get the symbol */
  412.     sym = xlgasymornil();    /* TAA fix */
  413.     xllastarg();
  414.  
  415.     /* handle NIL */
  416.     if (sym == NIL) return (NIL);
  417.  
  418.     /* get the global value */
  419.     while ((val = getvalue(sym)) == s_unbound)
  420.         xlunbound(sym);
  421.  
  422.     /* return its value */
  423.     return (val);
  424. }
  425.  
  426. /* xsymfunction - get the functional value of a symbol */
  427. LVAL xsymfunction()
  428. {
  429.     LVAL sym,val;
  430.  
  431.     /* get the symbol */
  432.     sym = xlgasymornil();        /* TAA fix */
  433.     xllastarg();
  434.  
  435.     /* handle NIL */
  436.     if (sym == NIL) {
  437.         while (1)
  438.             xlfunbound(sym);
  439.     }
  440.  
  441.  
  442.     /* get the global value */
  443.     while ((val = getfunction(sym)) == s_unbound)
  444.         xlfunbound(sym);
  445.  
  446.     /* return its value */
  447.     return (val);
  448. }
  449.  
  450. /* xsymplist - get the property list of a symbol */
  451. LVAL xsymplist()
  452. {
  453.     LVAL sym;
  454.  
  455.     /* get the symbol */
  456.     sym = xlgasymornil();    /* TAA fix */
  457.     xllastarg();
  458.  
  459.     /* return the property list */
  460.     return (sym == NIL ? NIL : getplist(sym));
  461. }
  462.  
  463. /* xget - get the value of a property */
  464. LVAL xget()
  465. {
  466.     LVAL sym,prp;
  467.  
  468.     /* get the symbol and property */
  469.     sym = xlgasymbol();
  470.     prp = xlgasymbol();
  471.     xllastarg();
  472.  
  473.     /* retrieve the property value */
  474.     return (xlgetprop(sym,prp));
  475. }
  476.  
  477. /* xputprop - set the value of a property */
  478. LVAL xputprop()
  479. {
  480.     LVAL sym,val,prp;
  481.  
  482.     /* get the symbol and property */
  483.     sym = xlgasymbol();
  484.     val = xlgetarg();
  485.     prp = xlgasymbol();
  486.     xllastarg();
  487.  
  488.     /* set the property value */
  489.     xlputprop(sym,val,prp);
  490.  
  491.     /* return the value */
  492.     return (val);
  493. }
  494.  
  495. /* xremprop - remove a property value from a property list */
  496. LVAL xremprop()
  497. {
  498.     LVAL sym,prp;
  499.  
  500.     /* get the symbol and property */
  501.     sym = xlgasymbol();
  502.     prp = xlgasymbol();
  503.     xllastarg();
  504.  
  505.     /* remove the property */
  506.     xlremprop(sym,prp);
  507.  
  508.     /* return nil */
  509.     return (NIL);
  510. }
  511.  
  512. /* xhash - compute the hash value of a string or symbol */
  513. LVAL xhash()
  514. {
  515.     char *str;
  516.     LVAL len,val;
  517.     int n;
  518.  
  519.     /* get the string and the table length */
  520.     val = xlgetarg();
  521.     len = xlgafixnum(); n = (int)getfixnum(len);
  522.     xllastarg();
  523.  
  524.     /* get the string */
  525.     if (symbolp(val))
  526.                 str = getstring(getpname(val));
  527.     else if (stringp(val))
  528.                 str = getstring(val);
  529.     else
  530.                 xlbadtype(val);
  531.  
  532.  
  533.     /* return the hash index */
  534.     return (cvfixnum((FIXTYPE)hash(str,n)));
  535. }
  536.  
  537.  
  538.  
  539. /* xaref - array reference function */
  540. LVAL xaref()
  541. {
  542.     LVAL array,index;
  543.     FIXTYPE i;            /* TAA fix */
  544.  
  545.     /* get the array (may be a string) and the index */
  546. #ifdef COMMONLISP        /* allows strings to work with AREF */
  547.     array = xlgetarg();
  548. #else
  549.     array = xlgavector();
  550. #endif
  551.     index = xlgafixnum(); i = /*(int) */ getfixnum(index);        /* TAA fix */
  552.     xllastarg();
  553.  
  554. #ifdef COMMONLISP
  555.     if (stringp(array)) {    /* extension -- allow fetching chars from string*/
  556.         if (i < 0 || i >= getslength(array)-1)
  557.             xlerror("string index out of bounds",index);
  558.         return (cvchar(getstringch(array,i)));
  559.     }
  560.         
  561.     if (!vectorp(array)) xlbadtype(array);    /* type must be array */
  562. #endif
  563.  
  564.     /* range check the index */
  565.     if (i < 0 || i >= getsize(array))
  566.         xlerror("array index out of bounds",index);
  567.  
  568.     /* return the array element */
  569.     return (getelement(array,(int)i));    /* TAA fix -- casting */
  570. }
  571.  
  572. /* xmkarray - make a new array */
  573. LVAL xmkarray()
  574. {
  575.     LVAL size;
  576.     int n;
  577.  
  578.     /* get the size of the array */
  579.     size = xlgafixnum() ; n = (int)getfixnum(size);
  580.     if ((n<0) || getfixnum(size) != (long)n)
  581.         xlerror("bad array size",size);
  582.     xllastarg();
  583.  
  584.     /* create the array */
  585.     return (newvector(n));
  586. }
  587.  
  588. /* xvector - make a vector */
  589. LVAL xvector()
  590. {
  591.     LVAL val;
  592.     int i;
  593.  
  594.     /* make the vector */
  595.     val = newvector(xlargc);
  596.  
  597.     /* store each argument */
  598.     for (i = 0; moreargs(); ++i)
  599.         setelement(val,i,nextarg());
  600.     xllastarg();
  601.  
  602.     /* return the vector */
  603.     return (val);
  604. }
  605.  
  606. /* xerror - special form 'error' */
  607. LVAL xerror()
  608. {
  609.     LVAL emsg,arg;
  610.  
  611.     /* get the error message and the argument */
  612.     emsg = xlgastring();
  613.     arg = (moreargs() ? xlgetarg() : s_unbound);
  614.     xllastarg();
  615.  
  616.     /* signal the error */
  617.     return (xlerror((char *)getstring(emsg),arg));
  618. }
  619.  
  620. /* xcerror - special form 'cerror' */
  621. LVAL xcerror()
  622. {
  623.     LVAL cmsg,emsg,arg;
  624.  
  625.     /* get the correction message, the error message, and the argument */
  626.     cmsg = xlgastring();
  627.     emsg = xlgastring();
  628.     arg = (moreargs() ? xlgetarg() : s_unbound);
  629.     xllastarg();
  630.  
  631.     /* signal the error */
  632.     xlcerror(getstring(cmsg),getstring(emsg),arg);
  633.  
  634.     /* return nil */
  635.     return (NIL);
  636. }
  637.  
  638. /* xbreak - special form 'break' */
  639. LVAL xbreak()
  640. {
  641.     LVAL emsg,arg;
  642.  
  643.     /* get the error message */
  644.     emsg = (moreargs() ? xlgastring() : NIL);
  645.     arg = (moreargs() ? xlgetarg() : s_unbound);
  646.     xllastarg();
  647.  
  648.     /* enter the break loop */
  649.     xlbreak((emsg ? getstring(emsg) : "**BREAK**"),arg);
  650.  
  651.     /* return nil */
  652.     return (NIL);
  653. }
  654.  
  655. /* xcleanup - special form 'clean-up' */
  656. LVAL xcleanup()
  657. {
  658.     xllastarg();
  659.     xlcleanup();
  660.     return (NIL);
  661. }
  662.  
  663. /* xtoplevel - special form 'top-level' */
  664. LVAL xtoplevel()
  665. {
  666.     xllastarg();
  667.     xltoplevel();
  668.     return (NIL);
  669. }
  670.  
  671. /* xcontinue - special form 'continue' */
  672. LVAL xcontinue()
  673. {
  674.     xllastarg();
  675.     xlcontinue();
  676.     return (NIL);
  677. }
  678.  
  679. /* xevalhook - eval hook function */
  680. LVAL xevalhook()
  681. {
  682.     LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
  683.  
  684.     /* protect some pointers */
  685.     xlstkcheck(3);
  686.     xlsave(oldenv);
  687.     xlsave(oldfenv);
  688.     xlsave(newenv);
  689.  
  690.     /* get the expression, the new hook functions and the environment */
  691.     expr = xlgetarg();
  692.     newehook = xlgetarg();
  693.     newahook = xlgetarg();
  694.     newenv = (moreargs() ? xlgalist() : NIL);
  695.     xllastarg();
  696.  
  697.     /* bind *evalhook* and *applyhook* to the hook functions */
  698.     olddenv = xldenv;
  699.     xldbind(s_evalhook,newehook);
  700.     xldbind(s_applyhook,newahook);
  701.  
  702.     /* establish the environment for the hook function */
  703.     if (newenv) {
  704.         oldenv = xlenv;
  705.         oldfenv = xlfenv;
  706.         xlenv = car(newenv);
  707.         xlfenv = cdr(newenv);
  708.     }
  709.  
  710.     /* evaluate the expression (bypassing *evalhook*) */
  711.     val = xlxeval(expr);
  712.  
  713.     /* restore the old environment */
  714.     xlunbind(olddenv);
  715.     if (newenv) {
  716.         xlenv = oldenv;
  717.         xlfenv = oldfenv;
  718.     }
  719.  
  720.     /* restore the stack */
  721.     xlpopn(3);
  722.  
  723.     /* return the result */
  724.     return (val);
  725. }
  726.  
  727. #ifdef APPLYHOOK
  728. /* xapplyhook - apply hook function */
  729. LVAL xapplyhook()
  730. {
  731.     LVAL fcn,args,newehook,newahook,olddenv,val;
  732.  
  733.     /* get the function, arguments, and the new hook functions */
  734.     fcn = xlgetarg();
  735.     args = xlgetarg();
  736.     newehook = xlgetarg();
  737.     newahook = xlgetarg();
  738.     xllastarg();
  739.  
  740.     /* bind *evalhook* and *applyhook* to the hook functions */
  741.     olddenv = xldenv;
  742.     xldbind(s_evalhook,newehook);
  743.     xldbind(s_applyhook,newahook);
  744.  
  745.     /* apply function (apply always bypasses hooks) */
  746.     val = xlapply(pushargs(fcn,args));
  747.  
  748.     /* restore the old environment */
  749.     xlunbind(olddenv);
  750.  
  751.     /* return the result */
  752.     return (val);
  753. }
  754.  
  755. #endif
  756.